home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / ARGTYP.f < prev    next >
Encoding:
Text File  |  1992-07-31  |  3.9 KB  |  122 lines
  1.       SUBROUTINE ARGTYP(STRING,CALLFL,I1,I2,ARG)
  2. *-----------------------------------------------------------------------
  3. *   
  4. *--- returns a list of argument types   
  5. *--- input  
  6. *    STRING(I1:I2) = '(...)' argument list  
  7. *    CALLFL        = .TRUE. if argument list of a caller, else .FALSE.  
  8. *--- output 
  9. *    ARG           character variable, 1 ch./argument   
  10. *                  'I' = integer
  11. *                  'R' = real   
  12. *                  'D' = double prec.   
  13. *                  'K' = complex
  14. *                  'C' = character  
  15. *                  'L' = logical
  16. *                  'P' = procedure (subroutine or function passed)  
  17. *                  '*' = alternate ret. 
  18. *                  '$' = not determined 
  19. *   
  20. *   the rest is blank.  
  21. *-----------------------------------------------------------------------
  22.       include 'PARAM.h' 
  23.       include 'ALCAZA.h' 
  24.       include 'CONDEC.h' 
  25.       include 'STATE.h' 
  26.       CHARACTER STRING*(*),ARG*(*),STYP*1, STEMP*1,SNAME*(MXNMCH),  
  27.      +ATYP*7
  28.       LOGICAL BRNONE,CALLFL 
  29.       DATA ATYP/'IRLKDC$'/  
  30.       include 'CONDAT.h' 
  31.       KPOS=I1   
  32.       N=0   
  33.    10 CONTINUE  
  34.       IPT=KPOS  
  35. *--- find end of each argument  
  36.       CALL POSCH(',',STRING,IPT+1,I2, .FALSE.,0,KPOS,ILEV)  
  37.       IF(KPOS.EQ.0)  KPOS=I2
  38.       N=N+1 
  39.       STEMP=STRING(IPT+1:IPT+1) 
  40.       IF(STEMP.EQ.' ')  THEN
  41.          IPT=IPT+1  
  42.          STEMP=STRING(IPT+1:IPT+1)  
  43.       ENDIF 
  44.       IF(STEMP.EQ.'*')  THEN
  45.          ARG(N:N)='*'   
  46.       ELSE  
  47.          IF(STEMP.EQ.'+'.OR.STEMP.EQ.'-') THEN  
  48.             IPT=IPT+1   
  49.             STEMP=STRING(IPT+1:IPT+1)   
  50.             IF(STEMP.EQ.' ') THEN   
  51.                IPT=IPT+1
  52.                STEMP=STRING(IPT+1:IPT+1)
  53.             ENDIF   
  54.          ENDIF  
  55.          IF(INDEX('0123456789(.{',STEMP).NE.0) THEN 
  56.             CALL GETCON(STRING,IPT+1,KPOS,KLCH,STYP)
  57.             IF(KLCH.EQ.0) GOTO 60   
  58.             IF(KLCH+1.EQ.KPOS.OR.(KLCH+2.EQ.KPOS .AND.STRING(KLCH+1:KLCH
  59.      +      +1).EQ.' ' )) THEN  
  60. *--- argument is a simple constant  
  61.                ARG(N:N)=STYP
  62.             ELSE
  63.                GOTO 60  
  64.             ENDIF   
  65.          ELSEIF(ALPHCH(STEMP)) THEN 
  66.             CALL GETNAM(STRING,IPT+1,KPOS,KFCH, KNAM)   
  67.             KLCH=KNAM   
  68.             STEMP=STRING(KLCH+1:KLCH+1) 
  69.             IF(STEMP.EQ.' ') THEN   
  70.                KLCH=KLCH+1  
  71.                STEMP=STRING(KLCH+1:KLCH+1)  
  72.             ENDIF   
  73.             IF(STEMP.EQ.'(') THEN   
  74. *--- check for dimensioned variable, or function
  75.                CALL SKIPLV(STRING,KLCH+2,KPOS, .FALSE.,KLCH,ILEV)   
  76.                STEMP=STRING(KLCH+1:KLCH+1)  
  77.                IF(STEMP.EQ.' ') THEN
  78.                   KLCH=KLCH+1   
  79.                   STEMP=STRING(KLCH+1:KLCH+1)   
  80.                ENDIF
  81.                BRNONE=.FALSE.   
  82.             ELSE
  83.                BRNONE=.TRUE.
  84.             ENDIF   
  85.             IF(KLCH+1.EQ.KPOS) THEN 
  86. *--- simple argument
  87.                SNAME=' '
  88.                CALL GETNBL(STRING(KFCH:KNAM),SNAME, NN) 
  89.                DO 20 IPOS=1,NSNAME  
  90.                   IF(SNAME.EQ.SNAMES(ISNAME+IPOS)) GOTO 30  
  91.    20          CONTINUE 
  92.                GOTO 60  
  93.    30          CONTINUE 
  94.                NT=NAMTYP(ISNAME+IPOS)   
  95.                IF(BRNONE.AND. (CALLFL.AND.(ITBIT(NT,15).NE.0.OR.ITBIT   
  96.      +         (NT,17).NE.0) .OR.(.NOT.CALLFL.AND.ITBIT(NT,12).NE.0)))  
  97.      +         THEN 
  98. *--- subroutine or function passed as argument  
  99.                   ARG(N:N)='P'  
  100.                ELSE 
  101.                   DO 40 I=1,6   
  102.                      K=NT/2 
  103.                      IF(NT-2*K.GT.0) GOTO 50
  104.                      NT=K   
  105.    40             CONTINUE  
  106.    50             CONTINUE  
  107.                   ARG(N:N)=ATYP(I:I)
  108.                ENDIF
  109.             ELSE
  110.                GOTO 60  
  111.             ENDIF   
  112.          ELSE   
  113.             GOTO 60 
  114.          ENDIF  
  115.       ENDIF 
  116.       GOTO 70   
  117.    60 CONTINUE  
  118.       ARG(N:N)=ATYP(7:7)
  119.    70 CONTINUE  
  120.       IF(KPOS.LT.I2) GOTO 10
  121.   999 END   
  122.